{-# LANGUAGE PatternGuards              #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusExpr.Utils
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC (ViewPatterns)
--
-- Utils.
--
--------------------------------------------------------------------------------

module WumpusExpr.Utils
  (

    truncatedDouble

  , blank_doc
  , vcatBlank

  , padTextR
  , commaSep
  , tupled
  , bitwiseNotU

  , braceBlock

  , psCommand  
  , psCommandV

  -- * Hughes lists
  , H  
  , emptyH
  , wrapH
  , consH
  , snocH
  , appendH
  , fromH

  ) where

import Text.PrettyExprHPJ                   -- package: pretty-expr-hpj


import Text.PrettyPrint.HughesPJ            -- package: pretty

import Data.List ( intersperse )




-- | Truncate the printed decimal representation of a Double.
-- This may be prefered to 'showFFloat' from Numeric as it 
-- produces shorter representations when the value has trailing
-- zeros.
-- 
-- 0.000000000 becomes 0.0 rather than however many digs are 
-- specified.
--  
truncatedDouble :: Double -> Doc
truncatedDouble d | abs d < 0.0001  = text $ "0.0"
                 | d < 0.0          = text $ '-' :  show (abs tx)
                 | otherwise        = text $ show tx
  where
    tx :: Double
    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0

roundi :: RealFrac a => a -> Integer
roundi = round

-- | blank_doc - can be used to make blank lines whereas @empty@
-- is absorbed.
--
blank_doc :: Doc
blank_doc = zeroWidthText ""

-- | Vertical concatentation with blank line separator.
--
vcatBlank :: [Doc] -> Doc
vcatBlank = vcat . intersperse blank_doc

padTextR :: Int -> String -> Doc
padTextR i ss | len <- length ss
              , len < i           = text ss <> text (replicate (i -len) ' ')
padTextR _ ss                     = text ss


commaSep :: [Doc] -> Doc
commaSep []     = empty
commaSep [a]    = a
commaSep (a:as) = a <> comma <+> commaSep as



tupled :: [Doc] -> Doc
tupled ds = parens $ hcat $ punctuate comma ds



braceBlock :: Int -> [Doc] -> Doc
braceBlock i ds = vcat [ lbrace, nest i (vcat ds), rbrace ]


-- | Bitwise not - H98 pseudo precedence.
--
-- > ~ (prefix 9)
--
--
bitwiseNotU             :: DocE -> DocE
bitwiseNotU             = Unary $ prefix 9 NoSpace "~"


-- | Better to supply in prefix and generate as postfix 
-- otherwise we get line fitting problems in the Haskell source.
--
psCommand :: String -> [Doc] -> Doc
psCommand name []       = text name
psCommand name args     = hsep args <+> text name


-- | Draw a command /vertically/ i.e. the args are vertically
-- concatenated. This is pertinent for the ifelse command.
--
psCommandV :: String -> [Doc] -> Doc
psCommandV name [] = text name
psCommandV name args     = vcat args <+> text name


--------------------------------------------------------------------------------
-- Hughes list

type H a = [a] -> [a]

emptyH :: H a
emptyH = id

wrapH :: a -> H a
wrapH a = (a:)

consH :: a -> H a -> H a
consH a h = (a:) . h

snocH :: H a -> a -> H a
snocH h a = h . (a:)

appendH :: H a -> H a -> H a
appendH = (.)

fromH :: H a -> [a]
fromH h = h []